home *** CD-ROM | disk | FTP | other *** search
- {
- From: ka9dgx@interaccess.com (Mike Warot)
-
- Here is the code I wrote to do cooperative multitasking in TP4, and have
- since used in TP5, TP6, TP7. This version works with TP7, I make no
- guarantees for earlier versions.
- }
-
- Unit Tasker;
- {
- Non-Preemptive MultiTasking Unit
- for Turbo Pascal Version 4
-
- Author : Michael Warot - Blue Star Systems
- Date : November 1987
- Purpose : Simple multi-tasking for turbo pascal 4.0
- Version : 1.10
-
- V1.10 August 1988 MAW - After much modification, added LastP to
- point to the highest numbered active process.
- With MaxProc set to 30 and 2 tasks, took
- effective yield time down from 240 uS to 38 uS
- V1.04 March 1988 MAW - Modify record used to save process, now
- use a pointer instead of 2 words to save
- the stack frame.
- Eliminate redundant variable NextP
- V1.03 March, 1988 MAW - Modify code to save video state for a given
- process. A flag Video_Save toggles this.
- V1.02 March, 1988 MAW - Modify code to support Sleep Function
- Added procedures LOCK and UNLOCK to permit
- use of non-reentrant procedures in programs
- V1.01 January, 1988 MAW - Remove obsolete startup function Init_Tasking.
- Put in some documentation. Clean up code.
- V1.00 November, 1987 MAW - Initial version, simple and crude, but it works.
- }
- {$F+ Force FAR calls - must be on}
- Interface
- Uses
- Crt,Timer2; { For saving screen status, etc }
-
- Type
- FlagPtr = ^Boolean; { Pointer to a flag }
- Var
- Save_Video : Boolean; { True for cursor saving }
-
- Function Fork:Boolean; { Call this procedure to spawn a new process. The
- procedure will return to your program twice. The
- first time it will be the root process, and will
- return a value of false, the second time it will
- return a value of true }
-
- Procedure Raw_Yield;
-
-
- Procedure Yield; { Call this procedure often in your code. This is the
- heart of the Multi-Tasking, it will return after all
- of the other processes have a crack at it. }
-
- Procedure Sleep(Flag : FlagPtr);
- { Call this procedure with an address of a flag which
- when TRUE, will re-awaken the process. Upon entry
- this procedure will test the value of this flag, and
- if FALSE, will mark the process HIBER.
- This procedure makes a call to YIELD in all cases.
- Note : Don't let all of you processes Sleep, or
- you could put things into a deadlock. }
-
- Procedure Lock(Resource : Byte);
- { This procedure allows the programmer to insure that
- a procedure is not entered twice, it does this by
- having the second call yield until the resource is
- free, using Sleep }
-
- Procedure UnLock(Resource : Byte);
- { This procedure unlocks a resource, allowing it to be
- used by other processes }
-
- Procedure KillProc; { This procedure is intended to be called by a process
- that has done all of it's work. It marks the process
- as one that is 'DEAD' and thus never re-awakens }
-
- Function Child_Process:Boolean;
- { This function returns True if the calling procedure
- is a child process. This test should be used to branch
- into a specific procedure for a given task. }
-
- Procedure SetPriority(P : Integer);
-
- Function ProcessCount:Integer;
-
- Procedure Wait(TicksToWait : Longint);
- { This procedure causes a task to wait by calling
- yield until DT(timer2 unit) deterimes that
- TicksToWait timer ticks have elapsed }
-
- Implementation
- {
- Hide this from the users....
-
- These procedures work on the following basis:
- 1> For each process, there is an amount of memory reserved for
- a machine stack, this is called a Stack Frame. This holds
- the current state of a given process.
-
- 2> The process table (Procs) contains pointers to all of the
- Stack Frames. When a task is to be swapped out, it's state
- is saved in it's own stack, then the frame pointer is placed
- in (Procs) until the process is to be swapped back in.
-
- 3> Every one in a while, when a task has some time to share,
- it makes a call to Yield, which does all of the swapping.
- }
- Const
- MaxProc = 100; { Maximum number of processes
- Adjust for your purposes.. }
-
- Type
- ProcState = (Dead,
- Kill,
- Live,
- Slow, { Running, but in background }
- Pause, { Waiting for above }
- Hiber); { What is the process doing? }
-
- Task_Rec = Record
- Frame : Pointer; { Frame save area}
- ID : Word; { Process Number }
- FrameBlk : Pointer; { Frame block }
- FrameSiz : Word; { Amount of memory user }
- State : ProcState; { Is it a live process ? }
- HiberPtr : FlagPtr; { Pointer to "WAKE" flag }
- Priority : LongInt; { priority (0=Real Time) }
- NextTime : Longint; { Next wake up call @ }
- End; { Record }
- Var
- MaxStack : Word;
-
- SFrame : Pointer;
-
- Procs : Array[0..MaxProc] of Task_Rec; { Keeps the process pointers }
- NextP, { Last live process number }
- ThisP, { Current process }
- LastP : Word; { Last Process number }
-
- LiveCount : Word; { How many thing happening? }
-
- Locks : Array[0..255] of Boolean; { Resource locks }
-
- Function Ticks:Longint;
- Begin
- Inline($FA); { CLI - Interupts off }
- Ticks := MemL[$0040:$006c];
- Inline($FB); { STI - back on again }
- End; { Ticks }
-
- {
- Here are the inline macros to handle the frame pointers for a task swap
- }
- Procedure SaveFrame;
- Inline( $89/$2E/SFrame { MOV [0000],BP }
- /$8C/$16/SFrame+2 { MOV [0002],SS } );
-
- Procedure LoadFrame;
- Inline( $8B/$2E/SFrame { MOV BP,[0000] }
- /$8E/$16/SFrame+2 { MOV SS,[0002] } );
-
- Function Fork:Boolean; { Create a new process }
- Var
- Tmp : Boolean;
- Begin
- SaveFrame; { Save current frame pointer }
- Tmp := True; { Assume child process }
- NextP := 0; { Search the process table for an }
- While (NextP <= MaxProc) AND { open entry for the new process }
- (Procs[NextP].State <> Dead) do
- Inc(NextP);
-
- If (NextP <= MaxProc) then { If table not full, then }
- begin
- If NextP > LastP then { If We past it, bump it }
- LastP := NextP;
-
- With Procs[NextP] do
- begin
- FrameSiz := MaxStack; { Set up size of area }
- GetMem(FrameBlk,FrameSiz);
- State := Live; { Note we're ready to go.... }
- ID := NextP; { Set up the new task }
- Frame :=
- Ptr(Seg(FrameBlk^),Ofs(SFrame^) ); { Setup stack }
-
- Priority := 0;
-
- Move(Mem[Seg(SFrame^) : Ofs(SFrame^)-2],
- Mem[Seg(FrameBlk^) : Ofs(SFrame^)-2],
- (MaxStack+2)-Ofs(SFrame^) );
- end;
- Inc(LiveCount); { Bump process counter }
- Tmp := False;
- end; { we can fork }
- LoadFrame;
- Fork := Tmp;
- End; { Raw_Fork }
-
- Procedure Raw_Yield; { Let the other task's go at it }
- Begin
- SaveFrame; { Save our current stack frame }
- Procs[ThisP].Frame := SFrame; { in our entry in Procs }
-
- If Procs[ThisP].State = Slow then
- With Procs[ThisP] do
- begin
- State := Pause;
- NextTime := Ticks+Priority;
- If NextTime > $001800ae then
- NextTime := NextTime - $001800ae;
- End; { with }
-
- If LiveCount >= 1 then { If we actually have a task to }
- begin { swap to, then.... }
- repeat { keep looking until we hit a }
- If ThisP < LastP then { live one }
- Inc(ThisP)
- else
- ThisP := 0;
-
- With Procs[ThisP] do
- Case State of
- Dead,
- Live : ;
-
- Hiber : If HiberPtr^ then { Check to see if we should }
- State := Live; { wake a sleeping process }
- Pause : If (Priority = 0) OR
- (Ticks > NextTime) then
- begin
- State := Slow; { handle slow task }
- end;
- Kill : If ThisP <> 0 then { Kill Off a process }
- Begin
- FreeMem(FrameBlk,FrameSiz);
- State := Dead;
- end;
- End; { Case State }
- until (Procs[ThisP].State = Live) or
- (Procs[ThisP].State = Slow);
- end;
-
- SFrame := Procs[ThisP].Frame; { Load new stack frame }
- LoadFrame;
- End; { Raw_Yield }
-
- Procedure Yield;
- Var
- ox,oy : byte;
- wmax,
- wmin : word;
- attr : byte;
- Begin
- If Not Save_Video then { Implemented this way in case the value changes }
- Raw_Yield
- else
- begin
- attr := TextAttr; { Save current colors }
- ox := WhereX; oy := WhereY; { save cursor position }
- wmin := WindMin; wmax := WindMax; { save window size }
-
- Raw_Yield; { actual Yield Call }
-
- WindMin := wmin; WindMax := wmax; { restore window size }
- GotoXY(ox,oy); { restore cursor }
- TextAttr := attr; { restore colors }
- end;
- End; { Yield_Plus }
-
- Procedure Sleep(Flag : FlagPtr); { Put a process to sleep }
- Begin
- If NOT Flag^ Then
- Begin
- Procs[ThisP].HiberPtr := Flag; { Set wake up pointer }
- Procs[ThisP].State := Hiber; { Mark this process as hibernating }
- End;
- Yield; { Do a yield, either way, to keep
- things going smoothly }
- End; { Sleep }
-
- Procedure Lock(Resource : Byte); { Lock a resource ID }
- Begin
- If NOT Locks[Resource] Then { If not open, then wait until }
- Sleep(@Locks[Resource]); { the resource becomes available }
-
- { Resource MUST be available now! }
-
- Locks[Resource] := FALSE; { Make it unavailable for use }
- End; { Lock }
-
- Procedure UnLock(Resource : Byte); { Unlock that resource }
- Begin
- Locks[Resource] := True; { Make the resource available }
- End; { UnLock }
-
- Procedure KillProc; { Stop a process in it's tracks }
- Begin
- If LiveCount > 1 then { if we are actually swapping then }
- begin
- Procs[ThisP].State := Kill; { mark us as dead }
- Dec(LiveCount); { Bump process count }
- Raw_Yield; { and yield. (Never returns) }
- {$IFDEF DEBUG}
- WriteLn('IN TASKER.PAS - FATAL ERROR, PROCESS EXCEPTION');
- {$ENDIF}
- end
- else { if not swapping, then }
- Halt(0); { exit to dos..... }
- End; { KillProc }
-
- Function Child_Process; { Returns true if not root process }
- Begin
- Child_Process := ThisP <> 0;
- End;
-
- Procedure SetPriority; { Set number of clicks between runs }
- Begin
- With Procs[ThisP] do
- begin
- Priority := P;
- If P = 0 then
- State := Live
- else
- State := Slow;
- end;
- End;
-
- Function ProcessCount;
- Begin
- ProcessCount := LiveCount;
- End;
-
- Procedure Wait(TicksToWait : Longint);
- var
- t : longint;
- begin
- If TicksToWait <= 0 then EXIT;
- StartTime(T);
- While DT(T) < TicksToWait do Yield;
- end;
-
- { Initialization code, called automatically by the user program,
- like it or not! }
- Procedure InitTasking;
- Var
- i : byte;
- Begin
- NextP := 0; { We are in the root process }
- ThisP := 0;
- LastP := 1; { Last Active process }
- FillChar(Procs,SizeOf(Procs),#0);
- Procs[0].State := Live;
- LiveCount := 1; { And one task is running (this one) }
- For i := 0 to 255 do
- Locks[i] := True; { All resources available }
- Save_Video := True;
- End;
-
- Begin
- MaxStack := Sptr+4;
- InitTasking;
- End.
-